home *** CD-ROM | disk | FTP | other *** search
- ;;; Compiled by f2cl version 2.0 beta 2002-05-06
- ;;;
- ;;; Options: ((:prune-labels nil) (:auto-save t) (:relaxed-array-decls t)
- ;;; (:coerce-assigns :as-needed) (:array-type ':simple-array)
- ;;; (:array-slicing nil) (:declare-common nil)
- ;;; (:float-format double-float))
-
- (in-package "SLATEC")
-
-
- (let ((zeror 0.0) (zeroi 0.0) (aic 1.2655121234846454))
- (declare (type double-float aic zeroi zeror))
- (defun zuoik (zr zi fnu kode ikflg n yr yi nuf tol elim alim)
- (declare (type (simple-array double-float (*)) yr yi)
- (type f2cl-lib:integer4 kode ikflg n nuf)
- (type double-float zr zi fnu tol elim alim))
- (prog ((cwrkr (make-array 16 :element-type 'double-float))
- (cwrki (make-array 16 :element-type 'double-float)) (i 0) (idum 0)
- (iform 0) (init 0) (nn 0) (nw 0) (aarg 0.0) (aphi 0.0) (argi 0.0)
- (argr 0.0) (asumi 0.0) (asumr 0.0) (ascle 0.0) (ax 0.0) (ay 0.0)
- (bsumi 0.0) (bsumr 0.0) (czi 0.0) (czr 0.0) (fnn 0.0) (gnn 0.0)
- (gnu 0.0) (phii 0.0) (phir 0.0) (rcz 0.0) (str 0.0) (sti 0.0)
- (sumi 0.0) (sumr 0.0) (zbi 0.0) (zbr 0.0) (zeta1i 0.0) (zeta1r 0.0)
- (zeta2i 0.0) (zeta2r 0.0) (zni 0.0) (znr 0.0) (zri 0.0) (zrr 0.0))
- (declare (type (simple-array double-float (16)) cwrkr cwrki)
- (type double-float zrr zri znr zni zeta2r zeta2i zeta1r zeta1i
- zbr zbi sumr sumi sti str rcz phir phii gnu gnn fnn czr czi
- bsumr bsumi ay ax ascle asumr asumi argr argi aphi aarg)
- (type f2cl-lib:integer4 nw nn init iform idum i))
- (setf nuf 0)
- (setf nn n)
- (setf zrr zr)
- (setf zri zi)
- (if (>= zr 0.0) (go label10))
- (setf zrr (- zr))
- (setf zri (- zi))
- label10
- (setf zbr zrr)
- (setf zbi zri)
- (setf ax (* (abs zr) 1.7321))
- (setf ay (coerce (abs zi) 'double-float))
- (setf iform 1)
- (if (> ay ax) (setf iform 2))
- (setf gnu (max fnu 1.0))
- (if (= ikflg 1) (go label20))
- (setf fnn (coerce (the f2cl-lib:integer4 nn) 'double-float))
- (setf gnn (- (+ fnu fnn) 1.0))
- (setf gnu (max gnn fnn))
- label20
- (if (= iform 2) (go label30))
- (setf init 0)
- (multiple-value-bind
- (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 var-9 var-10
- var-11 var-12 var-13 var-14 var-15 var-16)
- (zunik zrr zri gnu ikflg 1 tol init phir phii zeta1r zeta1i zeta2r
- zeta2i sumr sumi cwrkr cwrki)
- (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-15 var-16))
- (setf init var-6)
- (setf phir var-7)
- (setf phii var-8)
- (setf zeta1r var-9)
- (setf zeta1i var-10)
- (setf zeta2r var-11)
- (setf zeta2i var-12)
- (setf sumr var-13)
- (setf sumi var-14))
- (setf czr (- zeta2r zeta1r))
- (setf czi (- zeta2i zeta1i))
- (go label50)
- label30
- (setf znr zri)
- (setf zni (- zrr))
- (if (> zi 0.0) (go label40))
- (setf znr (- znr))
- label40
- (multiple-value-bind
- (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 var-9 var-10
- var-11 var-12 var-13 var-14 var-15 var-16)
- (zunhj znr zni gnu 1 tol phir phii argr argi zeta1r zeta1i zeta2r
- zeta2i asumr asumi bsumr bsumi)
- (declare (ignore var-0 var-1 var-2 var-3 var-4))
- (setf phir var-5)
- (setf phii var-6)
- (setf argr var-7)
- (setf argi var-8)
- (setf zeta1r var-9)
- (setf zeta1i var-10)
- (setf zeta2r var-11)
- (setf zeta2i var-12)
- (setf asumr var-13)
- (setf asumi var-14)
- (setf bsumr var-15)
- (setf bsumi var-16))
- (setf czr (- zeta2r zeta1r))
- (setf czi (- zeta2i zeta1i))
- (setf aarg (zabs argr argi))
- label50
- (if (= kode 1) (go label60))
- (setf czr (- czr zbr))
- (setf czi (- czi zbi))
- label60
- (if (= ikflg 1) (go label70))
- (setf czr (- czr))
- (setf czi (- czi))
- label70
- (setf aphi (zabs phir phii))
- (setf rcz czr)
- (if (> rcz elim) (go label210))
- (if (< rcz alim) (go label80))
- (setf rcz (+ rcz (f2cl-lib:flog aphi)))
- (if (= iform 2) (setf rcz (- rcz (* 0.25 (f2cl-lib:flog aarg)) aic)))
- (if (> rcz elim) (go label210))
- (go label130)
- label80
- (if (< rcz (- elim)) (go label90))
- (if (> rcz (- alim)) (go label130))
- (setf rcz (+ rcz (f2cl-lib:flog aphi)))
- (if (= iform 2) (setf rcz (- rcz (* 0.25 (f2cl-lib:flog aarg)) aic)))
- (if (> rcz (- elim)) (go label110))
- label90
- (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
- ((> i nn) nil)
- (tagbody
- (f2cl-lib:fset (f2cl-lib:fref yr (i) ((1 n))) zeror)
- (f2cl-lib:fset (f2cl-lib:fref yi (i) ((1 n))) zeroi)
- label100))
- (setf nuf nn)
- (go end_label)
- label110
- (setf ascle (/ (* 1000.0 (f2cl-lib:d1mach 1)) tol))
- (multiple-value-bind
- (var-0 var-1 var-2 var-3 var-4)
- (zlog phir phii str sti idum)
- (declare (ignore var-0 var-1))
- (setf str var-2)
- (setf sti var-3)
- (setf idum var-4))
- (setf czr (+ czr str))
- (setf czi (+ czi sti))
- (if (= iform 1) (go label120))
- (multiple-value-bind
- (var-0 var-1 var-2 var-3 var-4)
- (zlog argr argi str sti idum)
- (declare (ignore var-0 var-1))
- (setf str var-2)
- (setf sti var-3)
- (setf idum var-4))
- (setf czr (- czr (* 0.25 str) aic))
- (setf czi (- czi (* 0.25 sti)))
- label120
- (setf ax (/ (exp rcz) tol))
- (setf ay czi)
- (setf czr (* ax (cos ay)))
- (setf czi (* ax (sin ay)))
- (multiple-value-bind
- (var-0 var-1 var-2 var-3 var-4)
- (zuchk czr czi nw ascle tol)
- (declare (ignore var-0 var-1 var-3 var-4))
- (setf nw var-2))
- (if (/= nw 0) (go label90))
- label130
- (if (= ikflg 2) (go end_label))
- (if (= n 1) (go end_label))
- label140
- (setf gnu (+ fnu (f2cl-lib:int-sub nn 1)))
- (if (= iform 2) (go label150))
- (setf init 0)
- (multiple-value-bind
- (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 var-9 var-10
- var-11 var-12 var-13 var-14 var-15 var-16)
- (zunik zrr zri gnu ikflg 1 tol init phir phii zeta1r zeta1i zeta2r
- zeta2i sumr sumi cwrkr cwrki)
- (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-15 var-16))
- (setf init var-6)
- (setf phir var-7)
- (setf phii var-8)
- (setf zeta1r var-9)
- (setf zeta1i var-10)
- (setf zeta2r var-11)
- (setf zeta2i var-12)
- (setf sumr var-13)
- (setf sumi var-14))
- (setf czr (- zeta2r zeta1r))
- (setf czi (- zeta2i zeta1i))
- (go label160)
- label150
- (multiple-value-bind
- (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 var-9 var-10
- var-11 var-12 var-13 var-14 var-15 var-16)
- (zunhj znr zni gnu 1 tol phir phii argr argi zeta1r zeta1i zeta2r
- zeta2i asumr asumi bsumr bsumi)
- (declare (ignore var-0 var-1 var-2 var-3 var-4))
- (setf phir var-5)
- (setf phii var-6)
- (setf argr var-7)
- (setf argi var-8)
- (setf zeta1r var-9)
- (setf zeta1i var-10)
- (setf zeta2r var-11)
- (setf zeta2i var-12)
- (setf asumr var-13)
- (setf asumi var-14)
- (setf bsumr var-15)
- (setf bsumi var-16))
- (setf czr (- zeta2r zeta1r))
- (setf czi (- zeta2i zeta1i))
- (setf aarg (zabs argr argi))
- label160
- (if (= kode 1) (go label170))
- (setf czr (- czr zbr))
- (setf czi (- czi zbi))
- label170
- (setf aphi (zabs phir phii))
- (setf rcz czr)
- (if (< rcz (- elim)) (go label180))
- (if (> rcz (- alim)) (go end_label))
- (setf rcz (+ rcz (f2cl-lib:flog aphi)))
- (if (= iform 2) (setf rcz (- rcz (* 0.25 (f2cl-lib:flog aarg)) aic)))
- (if (> rcz (- elim)) (go label190))
- label180
- (f2cl-lib:fset (f2cl-lib:fref yr (nn) ((1 n))) zeror)
- (f2cl-lib:fset (f2cl-lib:fref yi (nn) ((1 n))) zeroi)
- (setf nn (f2cl-lib:int-sub nn 1))
- (setf nuf (f2cl-lib:int-add nuf 1))
- (if (= nn 0) (go end_label))
- (go label140)
- label190
- (setf ascle (/ (* 1000.0 (f2cl-lib:d1mach 1)) tol))
- (multiple-value-bind
- (var-0 var-1 var-2 var-3 var-4)
- (zlog phir phii str sti idum)
- (declare (ignore var-0 var-1))
- (setf str var-2)
- (setf sti var-3)
- (setf idum var-4))
- (setf czr (+ czr str))
- (setf czi (+ czi sti))
- (if (= iform 1) (go label200))
- (multiple-value-bind
- (var-0 var-1 var-2 var-3 var-4)
- (zlog argr argi str sti idum)
- (declare (ignore var-0 var-1))
- (setf str var-2)
- (setf sti var-3)
- (setf idum var-4))
- (setf czr (- czr (* 0.25 str) aic))
- (setf czi (- czi (* 0.25 sti)))
- label200
- (setf ax (/ (exp rcz) tol))
- (setf ay czi)
- (setf czr (* ax (cos ay)))
- (setf czi (* ax (sin ay)))
- (multiple-value-bind
- (var-0 var-1 var-2 var-3 var-4)
- (zuchk czr czi nw ascle tol)
- (declare (ignore var-0 var-1 var-3 var-4))
- (setf nw var-2))
- (if (/= nw 0) (go label180))
- (go end_label)
- label210
- (setf nuf -1)
- (go end_label)
- end_label
- (return (values nil nil nil nil nil nil nil nil nuf nil nil nil)))))
-
-